Shareware Grab Bag/Shareware Grab Bag.iso/011/sysid32.arc/SYSID.INC

Text File | 1988-07-08 | 12.8 KB | 613 lines

(*
**  SYSID.INC
**
**  The user functions and procedures for SYSID.PAS.
**
**  Steve Grant
**  Long Beach, CA
**  July 8,1988
*)

function cpuid : word;

(*
**  Returns in AX a word describing the host CPU and coprocessor:
**    AH7-AH4 = 0 (not used)
**    AH3     = 1 if interrupts corrupt multi-prefix string instructions
**    AH2     = 1 if PUSH SP writes, then decrements SP
**    AH1     = 1 if shift instructions use only lower five bits of second
**                register operand
**    AH0     = 1 if prefetch instruction queue is six bytes
**    AL      = 0 if no coprocessor present
**              1 if 8087 present
**              2 if 80287 present
*)

external;
(*$L CPUID *)

function scan(a : str9; b, c, d : word; var e : word) : boolean;

var
  i : longint;
  j : byte;
  len : byte;
  xbool1 : boolean;
  xbool2 : boolean;

begin
  i := c;
  len := length(a);
  xbool1 := false;
  repeat
    if i <= longint(d) - len + 1 then begin
      j := 0;
      xbool2 := false;
      repeat
        if j < len then
          if upcase(chr(mem[b : i + j])) = a[j + 1] then
            inc(j)
          else begin
            xbool2 := true;
            inc(i)
          end
        else begin
          xbool2 := true;
          xbool1 := true;
          e := i;
          scan := true
        end
      until xbool2
    end else begin
      xbool1 := true;
      scan := false
    end
  until xbool1
end;

function BIOSscan(a, b, c : word; var d : word) : boolean;

const
  max = 3;
  notice : array[1..max] of str9 = ('(C)', 'COPR.', 'COPYRIGHT');

var
  i : 1..max;
  len : byte;
  target : str9;
  xbool : boolean;
  xlong : longint;
  xword : word;

begin
  xlong := c;
  xbool := false;
  for i := 1 to max do begin
    target := notice[i];
    len := length(target);
    if xbool then
      xlong := longint(xword) - 2 + len;
    if (xlong >= b) and (xlong <= c) and (scan(target, a, b, xlong, xword))
      then
      xbool := true
  end;
  if xbool then begin
    while (xword > b) and (chr(mem[a : xword - 1]) in pchar1) do
      dec(xword);
    d := xword
  end;
  BIOSscan := xbool
end;

procedure BIOSunk(var a, b : word);

begin
  a := seg(strunk);
  b := ofs(strunk) + 1
end;

function diskread(drive : byte; start, sectors : word; var buffer) : word;

(*
**  Returns 0 if no error, else the error value from DOS.
**
**  This function was written by Terje Mathisen (BIX name "terjem").
*)

begin
  inline($1E /                          (* PUSH DS                         *)
         $55 /                          (* PUSH BP                         *)
         $8A / $46 / <drive /           (* MOV  AL,[BP+drive]              *)
         $8B / $56 / <start /           (* MOV  DX,[BP+start]              *)
         $8B / $4E / <sectors /         (* MOV  CX,[BP+sectors]            *)
         $C5 / $5E / <buffer /          (* LDS  BX,[BP+buffer]             *)
         $CD / $25 /                    (* INT  25H                        *)
         $72 / $02 /                    (* JC   error                      *)
         $31 / $C0 /                    (* XOR  AX,AX                      *)
                                        (* error:                          *)
         $59 /                          (* POP  CX                         *)
                                        (* ;fix broken stack               *)
         $5D /                          (* POP  BP                         *)
         $1F /                          (* POP  DS                         *)
         $89 / $46 / $FE)               (* MOV  [BP-2],AX                  *)
                                        (* ;TP4 local copy of return value *)
end;

procedure rjustify(a : string);

var
  i : byte;

begin
  for i := wherex to twidth - 1 - length(a) do
    write(' ');
  write(a)
end;

procedure border;

const
  ch = '═';

var
  i : byte;

begin
  for i := 1 to twidth - 1 do
    write(ch)
end;

procedure caption1(a : string);

begin
  textcolor(lightgray);
  write(a);
  textcolor(lightgreen)
end;

procedure caption2(a : string);

const
  capterm = ': ';

var
  i : byte;
  xbool : boolean;

begin
  i := length(a);
  while (i > 0) and (a[i] = ' ') do
    dec(i);
  insert(capterm, a, i + 1);
  caption1(a)
end;

function intinit(a : byte) : boolean;

begin
  intinit := (intseg[a] > $0000) or (intofs[a] > $0000)
end;

function nocarry : boolean;

begin
  nocarry := regs.flags and fcarry = $0000
end;

function hex(a : word; b : byte) : str4;

const
  digit : array[$0..$F] of char = '0123456789ABCDEF';

var
  i : byte;
  xstring : str4;

begin
  xstring := '';
  for i := 1 to b do begin
    insert(digit[a and $000F], xstring, 1);
    a := a shr 4
  end;
  hex := xstring
end;

procedure unknown(a : string; b : word; c : byte);

begin
  writeln('(unknown', ' ', a, ' ', hex(b, c), ')')
end;

function cbw(a, b : byte) : word;

begin
  cbw := a shl 8 + b
end;

function bin4(a : byte) : str4;

const
  digit : array[0..1] of char = '01';

var
  xstring : str4;
  i : byte;

begin
  xstring := '';
  for i := 3 downto 0 do begin
    insert(digit[a mod 2], xstring, 1);
    a := a shr 1
  end;
  bin4 := xstring
end;

function bin8(a : byte) : str9;

begin
  bin8 := bin4(a shr 4) + '_' + bin4(a and $0F)
end;

procedure showBIOS(a, b : word);

var
  xbool : boolean;
  xchar : char;

begin
  xbool := false;
  repeat
    xchar := chr(mem[a : b]);
    if xchar in pchar1 then begin
      write(xchar);
      if b < $FFFF then
        inc(b)
      else
        xbool := true
    end else
      xbool := true
  until xbool;
  writeln
end;

procedure dontknow;

begin
  writeln(strunk)
end;

procedure yesorno(a : boolean);

begin
  if a then
    write('yes')
  else
    write('no ')
end;

procedure segofs(a, b : word);

begin
  write(hex(a, 4), ':', hex(b, 4))
end;

function showchar(a : char) : char;

begin
  if a in pchar2 then
    showchar := a
  else
    showchar := '.'
end;

procedure EMMerr(a : byte);

begin
  case a of
    $80 : writeln('internal error in EMM software');
    $81 : writeln('malfunction in expanded memory hardware');
    $82 : writeln('memory manager busy');
    $83 : writeln('invalid handle');
    $84 : writeln('undefined function');
    $85 : writeln('no more handles available');
    $86 : writeln('error in save or restore of mapping context');
    $87 : writeln('not enough physical pages available');
    $88 : writeln('not enough free pages available');
    $89 : writeln('no pages requested');
    $8A : writeln('logical page outside range assigned to handle');
    $8B : writeln('invalid physical page number');
    $8C : writeln('page map hardware state save area full');
    $8D : writeln('mapping context already in save area');
    $8E : writeln('mapping context not in save area');
    $8F : writeln('undefined subfunction parameter')
    else
      unknown('expanded memory error', a, 2)
  end
end;

procedure pause;

var
  xbyte : byte;
  xchar : char;

begin
  if wherey + topline = tlength - 1 then begin
    xbyte := textattr;
    textcolor(green);
    write('(Press any key to continue)');
    repeat
    until keypressed;
    while keypressed do
      xchar := readkey;
    clrscr;
    writeln('(continued)');
    textattr := xbyte
  end
end;

procedure showMCB(MCB, ownerPID, parent, size : word);

var
  i : word;
  xbool : boolean;
  xchar : char;
  xlong1 : longint;
  xlong2 : longint;
  xlong3 : longint;
  xstring : string[12];
  xword : word;

begin
  xlong1 := $10 * longint(size);
  if parent = devseg then
    xstring := 'CONFIG.SYS'
  else if ownerPID = parent then
    xstring := 'COMMAND.COM'
    (*   BIX ms.dos/secrets #1496   *)
  else if (ownerPID = $0000) or (ownerPID = prefixseg) then
    xstring := '(free)'
  else begin
    xword := memw[ownerPID : $002C];
    i := 0;
    while memw[xword : i] > $0000 do
      inc(i);
    inc(i, 7);
    xstring := '';
    xbool := false;
    repeat
      xchar := chr(mem[xword : i]);
      if xchar in pchar2 then begin
        if xchar = '\' then
          xstring := ''
        else
          xstring := xstring + xchar;
        inc(i)
      end else begin
        xbool := true;
        if xchar > #0 then
          xstring := ''
      end
    until xbool;
  end;
  write(hex(MCB, 4), qspace3, hex(ownerPID, 4), qspace3, hex(parent, 4), '  '
    , qspace3, xlong1 : 6, qspace3, xstring);
  if MCB + 1 = ownerPID then begin
    for i := length(xstring) + 1 to 12 do
      write(' ');
    write(qspace3);
    xlong2 := $10 * longint(ownerPID);
    for i := $00 to $FF do begin
      xlong3 := $10 * longint(intseg[i]) + intofs[i];
      if (xlong2 <= xlong3) and (xlong3 <= xlong2 + xlong1) then begin
        if wherex > twidth - 3 then begin
          writeln;
          pause;
          write('    ', qspace3, '    ', qspace3, '      ', qspace3, '      '
            , qspace3, '            ', qspace3)
        end;
        write(hex(i, 2), ' ');
      end
    end
  end;
  writeln
end;

procedure showcolor(a : byte);

begin
  case(a) of
    black        : write('black');
    blue         : write('blue');
    green        : write('green');
    cyan         : write('cyan');
    red          : write('red');
    magenta      : write('magenta');
    brown        : write('brown');
    lightgray    : write('light gray');
    darkgray     : write('dark gray');
    lightblue    : write('light blue');
    lightgreen   : write('light green');
    lightcyan    : write('light cyan');
    lightred     : write('light red');
    lightmagenta : write('light magenta');
    yellow       : write('yellow');
    white        : write('white')
    else
      unknown('color', a, 2)
  end
end;

procedure offoron(a : byte);

begin
  if a = $00 then
    write('off')
  else
    write('on')
end;

procedure zeropad(a : byte);

begin
  if a < 10 then
    write('0');
  write(a)
end;

procedure showvers;

var
  xchar : char;

begin
  xchar := chr(country[9]);
  if osmajor > 0 then begin
    write(osmajor, xchar);
    zeropad(osminor);
    writeln
  end else
    writeln('1', xchar, 'x')
end;

procedure showecho(a : word);

var
  xbyte : byte;

begin
  xbyte := mem[DOScseg : a];
  case xbyte of
    $00 : writeln('off');
    $FF : writeln('on')
    else
      unknown('status', xbyte, 2)
  end
end;

procedure showbufs(a : word);

const
  bufsmax = 99;

var
  i : byte;
  xbool : boolean;
  xword1 : word;
  xword2 : word;
  xword3 : word;

begin
  i := 0;
  xword1 := memw[DOScseg : a];
  xword2 := memw[DOScseg : a + 2];
  xbool := false;
  repeat
    if i <= bufsmax then begin
      if xword1 < $FFFF then begin
        inc(i);
        xword3 := xword1;
        xword1 := memw[xword2 : xword3];
        xword2 := memw[xword2 : xword3 + 2]
      end else begin
        xbool := true;
        writeln(i)
      end
    end else begin
      xbool := true;
      dontknow
    end
  until xbool
end;
(*   BIX ms.dos/secrets #2   *)

procedure muxint(a : string; b : byte);

var
  xbyte : byte;

begin
  caption2(qindent + a);
  with regs do begin
    AX := b shl 8;
    intr($2F, regs);
    xbyte := AL;
    case xbyte of
      $00 : writeln('no; OK to install');
      $01 : writeln('no; not OK to install');
      $FF : writeln('yes')
      else
        unknown('status', xbyte, 2)
    end
  end
end;

function bin16(a : word) : str19;

begin
  bin16 := bin8(hi(a)) + '_' + bin8(lo(a))
end;

procedure drvname(a : byte);

begin
  write(chr(ord('A') + a), ': ')
end;

procedure media(a : byte);

procedure diskette(a, b : byte);

begin
  writeln('diskette (', a, '-sided, ', b, ' sectors)')
end;

begin (* procedure media *)
  caption2(qindent + 'Media');
  case a of
    $FF : diskette(2, 8);
    $FE : diskette(1, 8);
    $FD : diskette(2, 9);
    $FC : diskette(1, 9);
    $F9 : diskette(2, 15);
    $F8 : writeln('fixed disk')
    else
      unknown('media', a, 2)
  end
end;

procedure drvparms(a : byte; b : string);

var
  i : byte;
  xbool : boolean;

begin
  i := 0;
  xbool := false;
  repeat
    if i < $80 then
      with regs do begin
        AH := $08;
        DL := a + i;
        intr($13, regs);
        if AH = $00 then begin
          pause;
          inc(i);
          writeln(b, qspace4, i : 3, '   ', qspace4, DL : 3, '     ', qspace4
            , DH + 1 : 3, '  ', qspace4, cbw((CL and $C0) shr 6, CH) + 1 : 4
            , '     ', qspace4, CL and $3F : 2)
        end else
          xbool := true
      end
    else
      xbool := true
  until xbool
end;
(*   PC Magazine 7:5 p.339   *)

(*
** end subprograms
*)